home *** CD-ROM | disk | FTP | other *** search
/ System Booster / System Booster.iso / Archives / ARexxTools / RexxView.lha / RexxView / rexxview.f < prev    next >
Encoding:
FORTH Source  |  1991-07-31  |  6.4 KB  |  275 lines
  1. \ RexxView by Martin Kees
  2. \ JForth REXX peeker
  3. \ CLI utility to monitor REXX message traffic
  4. \ Usage: rexxview outfile
  5. \ Terminate by sending: closerexxview to REXX port
  6. \ 3/JUN/91
  7. \ Freely Distributable
  8.  
  9.  
  10. getmodule includes
  11. include? addport()   ju:exec_support
  12.  
  13. anew task_rexxview
  14.  
  15. 0" REXX"   0string RXSDIR   
  16.  
  17. :STRUCT RexxMsg
  18.      STRUCT Message rm_Node             (  EXEC message structure        )
  19.      APTR rm_TaskBlock              (  pointer to global structure   )
  20.      APTR rm_LibBase                (  library base                  )
  21.      LONG rm_Action                 (  command [action] code         )
  22.      LONG rm_Result1                (  primary result [return code]  )
  23.      LONG rm_Result2                (  secondary result              )
  24.    ( %?)   16 4 *  BYTES rm_Args    (  argument block [ARG0-ARG15]   )
  25.  
  26.      APTR rm_PassPort        (  forwarding port               )
  27.      APTR rm_CommAddr               (  host address [port name]      )
  28.      APTR rm_FileExt                (  file extension                )
  29.      LONG rm_Stdin                  (  input stream [filehandle]     )
  30.      LONG rm_Stdout                 (  output stream [filehandle]    )
  31.      LONG rm_avail                  (  future expansion              )
  32.    ;STRUCT 
  33.                                   (  size: 128 bytes               )
  34.  
  35. 15   constant MAXRMARG (  maximum arguments             )
  36.  
  37. (  Command [action] codes for message packets                           )
  38. $ 01000000   constant RXCOMM (  a command-level invocation    )
  39. $ 02000000   constant RXFUNC (  a function call               )
  40. $ 03000000   constant RXCLOSE (  close the port                )
  41. $ 04000000   constant RXQUERY (  query for information         )
  42. $ 07000000   constant RXADDFH (  add a function host           )
  43. $ 08000000   constant RXADDLIB (  add a function library        )
  44. $ 09000000   constant RXREMLIB (  remove a function library     )
  45. $ 0A000000   constant RXADDCON (  add/update a ClipList string  )
  46. $ 0B000000   constant RXREMCON (  remove a ClipList string      )
  47. $ 0C000000   constant RXTCOPN (  open the trace console        )
  48. $ 0D000000   constant RXTCCLS (  close the trace console       )
  49.  
  50. (  Command modifier flag bits            )
  51. 16   constant RXFB_NOIO (  suppress I/O inheritance?     )
  52. 17   constant RXFB_RESULT (  result string expected?       )
  53. 18   constant RXFB_STRING (  program is a "string file"?   )
  54. 19   constant RXFB_TOKEN (  tokenize the command line?    )
  55. 20   constant RXFB_NONRET (  a "no-return" message?        )
  56.  
  57. (  Modifier flags                )
  58. 1   RXFB_RESULT <<  constant RXFF_RESULT
  59. 1   RXFB_STRING <<  constant RXFF_STRING
  60. 1   RXFB_TOKEN <<  constant RXFF_TOKEN
  61. 1   RXFB_NONRET <<  constant RXFF_NONRET
  62. 1   RXFB_NOIO   <<  constant RXFF_NOIO
  63.  
  64. $ FF000000   constant RXCODEMASK
  65. $ 0000000F   constant RXARGMASK
  66.  
  67. 0 value rxpri
  68. 0 value myport
  69. 0 value rxport
  70. 0 value rmsg
  71. 0 value ofile
  72.  
  73.  
  74. : FORBID() ( -- )
  75.     callvoid exec_lib forbid
  76. ;
  77.  
  78. : PERMIT() ( -- )
  79.     callvoid exec_lib permit 
  80. ;
  81.  
  82.  
  83. : dscanlist ( port -- rexxport true | 0 )
  84.   begin
  85.     s@ ln_succ dup
  86.     IF dup s@ ln_name ?dup
  87.       IF
  88.        RXSDIR 4 compare
  89.        IF-NOT true exit
  90.        THEN
  91.       THEN 
  92.     THEN
  93.     dup
  94.   until-not  
  95. ;
  96.  
  97. \ Not needed after I found that the message port list
  98. \ is priority sorted but ...
  99. : uscanlist ( port -- rexxport true | 0 )
  100.   begin
  101.     s@ ln_pred dup
  102.     IF dup s@ ln_name ?dup
  103.       IF
  104.        RXSDIR 4 compare
  105.        IF-NOT true exit
  106.        THEN
  107.       THEN
  108.     THEN
  109.     dup
  110.   until-not
  111. ;
  112.  
  113. : Openmyport ( -- flag )
  114.   0 -> myport
  115.   forbid()
  116.   RXSDIR findport() dup -> rxport
  117.   IF  rxport ..@ ln_pri -> rxpri
  118.       RXSDIR rxpri 1+ Createport() -> myport
  119.   THEN
  120.   permit()
  121.   myport
  122. ;
  123.  
  124. : Closemyport ( -- )
  125.   myport   ?dup IF deleteport()
  126.                    0 -> myport
  127.                 THEN
  128. ;
  129.  
  130. : msg>taskname ( msg -- 0$task )
  131.   s@ mn_replyport
  132.   s@ mp_SigTask
  133.   s@ ln_name
  134. ;
  135.  
  136. : msg>arg0 ( msg -- 0str )
  137.   .. rm_args @ >rel 
  138. ;
  139.  
  140. : fcr
  141.   10 pad c! ofile pad 1 fwrite drop
  142. ;
  143.  
  144.  
  145. : >ofile ( srt -- )
  146.   ofile swap count fwrite drop
  147. ;
  148.  
  149. : ?0type ( 0str str -- )
  150.   ofile swap count fwrite drop
  151.   0count
  152.   ?dup IF ofile -rot fwrite drop
  153.        ELSE drop ofile " Null" fwrite drop
  154.        THEN
  155.   fcr
  156. ;
  157.  
  158. : term.rv ( msg -- )
  159.    replymsg()
  160.    begin myport getmsg() ?dup
  161.    while replymsg()
  162.    repeat
  163.    closemyport
  164.    ofile fclose
  165. ;
  166.  
  167. : SendToRexx ( msg -- flag )
  168.   forbid()
  169.   myport dscanlist
  170.   ?dup IF-NOT  myport uscanlist
  171.        THEN
  172.   IF swap putmsg()   true
  173.   ELSE   false
  174.   THEN
  175.   permit()
  176.   IF-NOT
  177.      " REXX port closed!" >ofile
  178.      term.rv
  179.   THEN
  180. ;
  181.  
  182. : aboutmsg
  183.   ofile " RexxView by Martin Kees " count fwrite drop fcr
  184.   ofile " (c) 1991 M C Kees"        count fwrite drop fcr
  185.   ofile " Freely Distributable"     count fwrite drop fcr
  186. ;
  187.  
  188.  
  189. : .action ( msg -- )
  190.   " Action: " swap
  191.   ..@ rm_action  RXCODEMASK AND
  192. CASE
  193. RXCOMM   OF   0" RXCOMM"
  194.          ENDOF
  195. RXFUNC   OF   0" RXFUNC"
  196.          ENDOF
  197. RXCLOSE  OF   0" RXCLOSE"
  198.          ENDOF
  199. RXQUERY  OF   0" RXQUERY"
  200.          ENDOF
  201. RXADDFH  OF   0" RXADDFH"
  202.          ENDOF
  203. RXADDLIB OF   0" RXADDLIB"
  204.          ENDOF
  205. RXREMLIB OF   0" RXREMLIB"
  206.          ENDOF
  207. RXADDCON OF   0" RXADDCON"
  208.          ENDOF
  209. RXREMCON OF   0" RXREMCON"
  210.          ENDOF
  211. RXTCOPN  OF   0" RXTCOPN"
  212.          ENDOF
  213. RXTCCLS  OF   0" RXTCCLS"
  214.          ENDOF
  215.          0" UNKNOWN" swap
  216. ENDCASE
  217.     swap ?0type
  218. ;
  219.  
  220. : .modifier ( msg -- )
  221.   " Modifier: " >ofile
  222.   ..@ rm_action
  223.   dup RXFF_RESULT  and IF " RXFB_RESULT " >ofile
  224.                        THEN
  225.   dup RXFF_STRING  and IF " RXFB_STRING " >ofile
  226.                        THEN
  227.   dup RXFF_TOKEN   and IF " RXFB_TOKEN  " >ofile
  228.                        THEN
  229.   dup RXFF_NONRET  and IF " RXFB_NONRET " >ofile
  230.                        THEN
  231.   dup RXFF_NOIO    and IF " RXFB_NOIO   " >ofile
  232.                        THEN
  233.   drop fcr
  234. ;
  235.  
  236.  
  237.  
  238. : rexxview ( -- )
  239.   new fileword
  240.   dup 1+ c@ ascii ? = over c@ 0= OR
  241.   IF drop cr
  242.      ." Usage: rexxview  OutputFileName" cr
  243.      ." Terminate by sending to REXX: closerexxview"  cr
  244.      exit
  245.   THEN
  246.   $fopen -> ofile
  247.   ofile
  248.  IF
  249.   openmyport
  250.   IF aboutmsg
  251.     BEGIN
  252.      myport waitport() drop
  253.      myport getmsg() -> rmsg
  254.      rmsg msg>taskname " From Task: " ?0type
  255.      rmsg .action
  256.      rmsg .modifier
  257.      rmsg msg>arg0
  258.       dup " Arg0: " ?0type fcr
  259.        0" closerexxview" 0count compare
  260.        IF-NOT rmsg term.rv
  261.               exit
  262.        THEN
  263.      rmsg sendtorexx
  264.     AGAIN
  265.   ELSE ofile fclose
  266.        rxport IF-NOT ." REXX not found " cr exit
  267.               THEN
  268.   THEN
  269.   myport IF-NOT ." No memory for RexxView port!" cr exit
  270.          THEN
  271.  ELSE
  272.   ." Couldn't open output file" cr
  273.  THEN
  274. ;
  275.